magic/vm-src/tags.c

#include <assert.h>
#include <stdlib.h>
#include <stdio.h>

#include "tags.h"
#include "headers.h"

scm scm_get_tag(scm s) {
  if(s & 0b111) return s & 0b111;
  return s & 0b111111;
}

scm mk_fals() { return atom_tag_fals; }

scm mk_true() { return atom_tag_true; }

scm mk_bool(scm b) {
  return b ? mk_true() : mk_fals();
}

scm mk_null() { return atom_tag_null; }

scm mk_symb(scm id) {
  assert(id < ((scm)1 << (64-6)));
  
  return (id << 6) |
    atom_tag_symb;
}

scm mk_char(char ch) {
  //assert(ch < ((scm)1 << (64-6)));
  
  return (ch << 6) |
    atom_tag_char;
}

scm mk_numb(num nm) {
  //assert(nm < ((scm)1 << (64-6)));
  
  return (nm << 6) |
    tag_numb;
}

scm mk_cons(scm *p) {
  return ((scm)p) |
    tag_cons;
}

scm mk_clos(scm *p) {
  return ((scm)p) |
    tag_clos;
}

scm mk_vect(scm *p) {
  return ((scm)p) |
    tag_vect;
}

scm mk_strn(scm *p) {
  return ((scm)p) |
    tag_strn;
}

scm get_symb(scm s) {
  assert(scm_get_tag(s) == atom_tag_symb);
  return s >> 6;
}

char get_char(scm s) {
  assert(scm_get_tag(s) == atom_tag_char);
  return s >> 6;
}

num get_numb(scm s) {
  assert(scm_get_tag(s) == tag_numb);
  return ((num)s) >> 6;
}

scm *get_cons(scm s) {
  assert(scm_get_tag(s) == tag_cons);
  return (scm*)(s & ~0b111);
}

scm get_cons_car(scm s) {
  scm *p = get_cons(s);
  return p[1];
}

scm get_cons_cdr(scm s) {
  scm *p = get_cons(s);
  return p[2];
}

void set_cons_car(scm s, scm x) {
  scm *p = get_cons(s);
  p[1] = x;
}

void set_cons_cdr(scm s, scm x) {
  scm *p = get_cons(s);
  p[2] = x;
}

scm *get_clos(scm s) {
  assert(scm_get_tag(s) == tag_clos);
  return (scm*)(s & ~0b111);
}

scm *get_vect(scm s) {
  assert(scm_get_tag(s) == tag_vect);
  return (scm*)(s & ~0b111);
}

scm *get_strn(scm s) {
  assert(scm_get_tag(s) == tag_strn);
  return (scm*)(s & ~0b111);
}

scm get_strn_len(scm s) {
  scm *p;
  p = get_strn(s);
  return p[1];
}

unsigned char *get_strn_data(scm s) {
  scm *p;
  p = get_strn(s);
  return (void*)(p+2);
}

scm clos_lbl(scm clo) {
  scm *ptr;

  ptr = get_clos(clo);

  return ptr[1];
}

scm clos_env_ref(scm clo, scm idx) {
  scm *ptr;
  scm hdr;

  ptr = get_clos(clo);
  
  hdr = ptr[0];
  
  assert(header_raw_size(hdr) == 1);
  
  if(idx < header_scm_size(hdr)) {
    return ptr[2 + idx];
  }
  else {
    fprintf(stderr, "env register index out of range %ld\n", idx);
    exit(-1);
  }
}

void clos_set_env(scm clo, scm idx, scm obj) {
  scm *ptr;
  scm hdr;

  ptr = get_clos(clo);
  
  hdr = ptr[0];
  
  assert(header_raw_size(hdr) == 1);
  
  if(idx < header_scm_size(hdr)) {
    ptr[2 + idx] = obj;
  }
  else {
    fprintf(stderr, "env register index out of range %ld\n", idx);
    exit(-1);
  }
}